home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / back_end / m68bookkeep.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  6.9 KB  |  185 lines
  1. (herald m68bookkeep (env t (orbit_top defs)))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define-constant *pointer-registers* 5)
  27. (define-constant *scratch-registers* 6)
  28. (define-constant *argument-registers* 3)
  29. (define-constant *real-registers* 11)
  30. (define-constant *pointer-temps* 64)
  31. (define-constant *scratch-temps* 5)
  32. (define-constant *no-of-registers* 
  33.                  (+ *pointer-temps* *scratch-temps* *real-registers*))
  34.  
  35. (define-constant *maximum-number-of-arguments* *pointer-temps*)             
  36.  
  37. (define-constant S0 0)
  38. (define-constant S1 1)
  39. (define-constant S2 2)
  40. (define-constant S3 3)
  41. (define-constant S4 4)
  42. (define-constant S5 5)
  43. (define-constant NARGS 5)
  44. (define-constant P 6)
  45. (define-constant A1 7)
  46. (define-constant A2 8)
  47. (define-constant A3 9)
  48. (define-constant AN 10)
  49. (define-constant AN-1 9)
  50. (define-constant TP -1)
  51. (define-constant nil-reg -2)
  52. (define-constant SP -3)
  53. (define-constant TASK -4)
  54. (define-constant SCRATCH -5)
  55.  
  56.  
  57. (define *pos-list1* (make-vector 4))
  58. (define *pos-list2* (make-vector 5))
  59.   
  60.  
  61. (let ((base  '((7 . rep/pointer)
  62.                (8 . rep/pointer)
  63.                (9 . rep/pointer))))
  64.   (set (vref *pos-list1* 0) (sublist base 0 0))
  65.   (set (vref *pos-list1* 1) (sublist base 0 1))
  66.   (set (vref *pos-list1* 2) (sublist base 0 2))
  67.   (set (vref *pos-list1* 3) (sublist base 0 3)))
  68.  
  69.  
  70. (let ((base  '((6 . rep/pointer)
  71.                (7 . rep/pointer)
  72.                (8 . rep/pointer)
  73.                (9 . rep/pointer))))
  74.   (set (vref *pos-list2* 0) (sublist base 0 0))
  75.   (set (vref *pos-list2* 1) (sublist base 0 1))
  76.   (set (vref *pos-list2* 2) (sublist base 0 2))
  77.   (set (vref *pos-list2* 3) (sublist base 0 3))
  78.   (set (vref *pos-list2* 4) (sublist base 0 4)))
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85. (define (reg-positions i proc?)       
  86.   (cond ((fx<= i (if proc? 4 3))
  87.          (vref (if proc? *pos-list2* *pos-list1*) i))
  88.         (else
  89.          (append (if proc? (vref *pos-list2* 4) (vref *pos-list1* 3))
  90.                  (make-num-list (fx- i (if proc? 4 3)))))))
  91.  
  92. (define (make-num-list amount)
  93.   (let ((end (fx+ (fx+ *real-registers* *argument-registers*) amount)))
  94.     (do ((i (fx+ *real-registers* *argument-registers*) (fx+ i 1))
  95.          (l '() (cons (cons i 'rep/pointer) l)))
  96.         ((fx>= i end) (reverse! l)))))
  97.  
  98.  
  99.  
  100.  
  101.  
  102. (define (do-trivial-lambda call-node node reg-rep)
  103.   (let ((offset (environment-cic-offset (lambda-env node)))
  104.         (reg (car reg-rep))
  105.         (hack (lambda (from to)
  106.                 (cond ((register? to)
  107.                        (emit m68/lea from to))
  108.                       (else
  109.                        (emit m68/pea from)
  110.                        (generate-pop to))))))
  111.     (cond ((eq? (lambda-strategy node) strategy/hack)
  112.            (hack (reg-offset SP (fx+ offset 2)) reg))
  113.           ((fx= offset 0)
  114.            (generate-move AN reg))
  115.           (else                   
  116.            (hack (reg-offset AN offset) reg)))
  117.     (cond ((reg-node (car reg-rep))
  118.                 => kill))
  119.     (lock (car reg-rep))))
  120.  
  121.  
  122. ;;; MAKE-HEAP-CLOSURE The first member of the closure corresponds to the
  123. ;;; template so we call %make-extend with this template and the size of the
  124. ;;; closure to be created.  Then we fill in the slots with the need variables
  125. ;;; and the addresses of templates for any closure-internal-closures.
  126.  
  127. (define (make-heap-closure node closure)
  128.   (if *assembly-comments?* (emit-comment "consing heap closure"))
  129.   (let* ((members (closure-members closure))
  130.          (template-binder (variable-binder (car members))))
  131.     (walk (lambda (var)
  132.             (lambda-queue (variable-binder var)))
  133.           members)
  134.     (free-register node AN)
  135.     (let ((cl (environment-closure (lambda-env template-binder))))
  136.       (cond ((closure-cit-offset cl)
  137.              (let ((acc (lookup node cl nil)))
  138.                (free-register node AN)
  139.                (generate-move acc AN)))
  140.             (else
  141.              (generate-move-address (template template-binder) AN))))
  142.     (lock AN)
  143.     (let ((hack (generate-extend node (closure-size closure))))
  144.       (lock hack)
  145.       (walk (lambda (pair)
  146.         (let ((var (car pair))
  147.               (offset (cdr pair)))
  148.           (cond ((eq? var *dummy-var*))
  149.                 ((memq? var members)
  150.                  (generate-move-address (template (variable-binder var)) hack)
  151.                  (generate-move hack (reg-offset AN (fx- offset tag/extend))))
  152.                 (else
  153.                  (really-rep-convert node
  154.                                      (access-value node var)
  155.                                      (variable-rep var)
  156.                                      (reg-offset AN
  157.                                                  (fx- offset tag/extend))
  158.                                      (variable-rep var))))))
  159.         (cdr (closure-env closure)))
  160.         (unlock hack))
  161.       (unlock AN)))
  162.  
  163. (define (generate-extend node n)
  164.   (free-register node S1)
  165.   (free-register node S2)
  166.   (generate-move (machine-num (fx- n CELL)) S1)   ;; don't include template
  167.   (let ((reg (get-register 'pointer node '*)))
  168.     (generate-slink-jump slink/make-extend)
  169.     reg))
  170.  
  171. (define (exchange-hack movers)
  172.   (if (fxn= (length movers) 2)
  173.       '#f
  174.       (destructure (((m1 m2) movers))
  175.         (cond ((and (eq? (arg-mover-from-rep m1) (arg-mover-to-rep m1))
  176.                     (eq? (arg-mover-from-rep m2) (arg-mover-to-rep m1))
  177.                     (fx= (arg-mover-from m1) (arg-mover-to m2))
  178.                     (fx= (arg-mover-from m2) (arg-mover-to m1))
  179.                     (register? (arg-mover-from m1))
  180.                     (register? (arg-mover-from m2)))
  181.                (emit m68/exg (arg-mover-from m1) (arg-mover-to m1))
  182.                '#t)
  183.               (else '#f)))))
  184.  
  185.